;;************************************************************************
;; histogrm.lsp 
;; contains code for new and revised methods for Luke's histogram
;; copyright (c) 1991-98 by Forrest W. Young
;;************************************************************************

;(send histogram-proto :menu-template
;      '(help dash link mouse resize-brush dash 
;             erase-selection focus-on-selection show-all color dash
;             selection slicer dash
;             change-bins dash 
;             print copy save content-only))

(send histogram-proto :size 250 250)

(defmeth histogram-proto :new (&rest args)
  (let ((object (apply #'call-next-method args))
	(content-only (position ':content-only args))
        )
    (when content-only (setf content-only (select args (1+ content-only))))
    (send object :add-slot 'show-normal)
    (send object :add-slot 'show-kernel)
    (send object :add-slot 'show-density)
    (send object :add-slot 'kernel-type)
    (send object :add-slot 'max-normal-pixel)
    (send object :add-slot 'slider)
    (send object :add-slot 'dens-dialog)
    (send object :add-slot 'normal-curve-color)
    (send object :add-slot 'kernel-curve-color)
    (send object :add-slot 'content-only)
    (defmeth object :normal-curve-color (&optional (symbol nil set))
      (if set (setf (slot-value 'normal-curve-color ) symbol))
      (slot-value 'normal-curve-color ))
    (defmeth object :kernel-curve-color (&optional (symbol nil set))
      (if set (setf (slot-value 'kernel-curve-color ) symbol))
      (slot-value 'kernel-curve-color ))
    (defmeth object :content-only (&optional (logical nil set))
      (if set (setf (slot-value 'content-only) logical))
      (slot-value 'content-only))
    (defmeth object :show-normal (&optional (logical nil set))
      (if set (setf (slot-value 'show-normal) logical))
      (slot-value 'show-normal))
    (defmeth object :show-kernel (&optional (logical nil set))
      (if set (setf (slot-value 'show-kernel) logical))
      (slot-value 'show-kernel))
    (defmeth object :show-density (&optional (logical nil set))
      (if set (setf (slot-value 'show-density) logical))
      (slot-value 'show-density))
    (defmeth object :kernel-type (&optional (logical nil set))
      (if set (setf (slot-value 'kernel-type) logical))
      (slot-value 'kernel-type))
    
    (defmeth object :switch-add-normal 
      (&key (color 'red) (kcolor 'green) line-width (draw t))
      (send object :show-normal (not (send object :show-normal)))
      (cond
        ((send object :show-normal)
         (send object :add-normal
               :draw draw 
               :color 'red ;(send object :normal-curve-color)
               :line-width line-width))
        (t
         (send object :clear-lines)
         (when (send object :show-kernel) 
               (send object :add-kernel 
                    (send object :kernel-type) 
                     :draw draw
                     :color 'green ;(send object :kernel-curve-color)
                     :line-width line-width)))))

    (defmeth object :switch-add-kernel (&key (color 'red) line-width (draw t))
      (send object :show-kernel (not (send object :show-kernel)))
      (cond 
        ((send object :show-kernel)
         (send object :add-kernel 
              (send object :kernel-type) 
               :draw draw
               :color 'green ;(send object :kernel-curve-color) 
               :line-width line-width))
        (t
         (send object :clear-lines)
         (when (send object :show-normal) 
               (send object :add-normal 
                     :draw draw
                     :color 'red ;(send object :normal-curve-color) 
                     :line-width line-width)))))
    (defmeth object :max-normal-pixel (&optional (logical nil set))
      (if set (setf (slot-value 'max-normal-pixel) logical))
      (slot-value 'max-normal-pixel))
    (send object :content-only content-only)
    (send object :make-two-plot-menus "HistoGram"
          :hotspot-items '(help dash new-x dash link dash
                           show-plots hide-plots close-plots dash 
                           print save copy dash on-top maximize)
          :popup-items   '(resize-brush dash 
                           select-all unselect-all show-all dash 
                           erase-selection focus-on-selection view-selection dash
                           color))
    (when content-only
          (send object :y-axis nil)
          (send object :x-axis nil))
    object))

(defmeth histogram-proto :unselect-all-points ()
  (send self :redraw)
  (call-next-method))

(defmeth histogram-proto :adjust-points-in-rect (&rest args)
  (when (or (send self :show-normal)
            (send self :show-kernel))
        (send self :redraw-content))
  (apply #'call-next-method args))

(defmeth histogram-proto :switch-use-color ()
  (send self :use-color (not (send self :use-color)))
  (send self :normal-curve-color (if (send self :use-color) 'red nil))
  (send self :kernel-curve-color (if (send self :use-color) 'green nil))
  (send self :redraw)
  (send self :use-color))

(defmeth histogram-proto :redraw ()
(let* ((overlay (first (send self :slot-value 'overlays)))
       (color-on? nil)
       (no-action-on? nil)
       )
    (when overlay
          ;(setf color-on? (and (send overlay :color-mode)
          ;                     (> *color-mode* 0) ))
          (setf color-on? t)
          (setf no-action-on? (equal 'no-action (send self :mouse-mode)))
          (when no-action-on?
                (send self :point-state (iseq (send self :num-points)) 
                      (if color-on? 'hilited 'normal)))
         ; (send self :clear-lines)
         ; (when (send self :show-normal) (send self :add-normal))
         ; (when (send self :show-kernel) (send self :add-kernel))
          (send self :use-color color-on?)
         ; (send self :normal-curve-color (if color-on? 'red nil))
         ; (send self :kernel-curve-color (if color-on? 'green nil))
          ))
  (call-next-method))

(defmeth histogram-proto :choose-density ()
  (when (> (send self :num-points) 2)
        (cond 
          ((not (send self :slot-value 'dens-dialog))
           (let* ((den-fun-state (list nil nil nil))
                  (monopoly-arguments nil)
                  (title  (send text-item-proto :new "Choose Curve"))
                  (Kernel-text (send text-item-proto :new "Kernel:"))
                  (normal (send toggle-item-proto :new "Normal Density"
                                :value (select den-fun-state 0)
                                :action #'(lambda () (send self :switch-add-normal))))
                  (kernel-type (send choice-item-proto :new
                                     (list "Bisquare" "Gaussian" "Triangular" "Uniform" )
                                     :value 0
                                     :action #'(lambda () 
                                                 (send self :put-kernel-type))))
                  (kernel (send toggle-item-proto :new "Kernel Density"
                                :value (select den-fun-state 1)
                                :action #'(lambda ()
                                            (send self :kernel-type (send kernel-type :value))
                                            (send self :switch-add-kernel))))
                  
                  (monopoly (send toggle-item-proto :new "MonoPoly Density"
                                  :value (select den-fun-state 2)))
                  (dialog (send dialog-proto :new
                                (list title normal 
                                      (list (list kernel (list kernel-text kernel-type))
                                            ;monopoly
                                            ))
                                :title "Distribution Curve"))
                  )
             (defmeth self :put-kernel-type ()
               (send self :kernel-type (send kernel-type :value))
               (when (send self :show-kernel)
                     (send self :switch-add-kernel)
                     (send self :switch-add-kernel)))
             (send self :add-subordinate dialog)
             (send self :slot-value 'dens-dialog dialog)))
          (t
           (send (send self :slot-value 'dens-dialog) :show-window)))))
          

(defmeth histogram-proto :add-normal (&key (color 'red) line-width (draw t))
        (let* ((current-variable (first (send self :content-variables)))
               (var (send self :point-coordinate  current-variable
                          (iseq (send self :num-points))))
               (ndim (- (send self :num-variables) 1))
               (mu (mean var))
               (s (standard-deviation var))
               (range (send self :range current-variable))
               (x (rseq (first range) (second range) 50))
               (y (/ (normal-dens (/ (- x mu) s)) s))
               (max-pix-now (second (send self :real-to-canvas mu (max y))))
               (zero-pix (second (send self :real-to-canvas mu 0)))
               (y (* y (/ (- zero-pix 50) (- zero-pix max-pix-now))))
               (overlay (first (send self :slot-value 'overlays)))
               )
          (when (not line-width) (setf line-width *line-width*))
          (send self :add-lines (append (repeat (list x) ndim) (list y))
                :draw nil
              ; :color (if (and (send overlay :color-mode)
              ;                 (> *color-mode* 0) ) color nil)
                :color color ;(send self :normal-curve-color)
                :width line-width)
          (when draw (send self :redraw))))


(defmeth histogram-proto :add-kernel 
                         (type-number &key (color 'green) line-width (draw t))
  (let* ((type (case type-number
                 (0 'b)
                 (1 'g)
                 (2 't)
                 (3 'u)))
         (current-variable (first (send self :content-variables)))
         (npts (send self :num-points))
         (ndim (- (send self :num-variables) 1))
         (varx (send self :point-coordinate current-variable (iseq npts)))
         (x (rseq (min varx) (max varx) 50))
         (maxyaxis (max (send self :range (1- (send self :num-variables)))))
         (y (second (kernel-dens varx :xvals 50 :type type)))
         (maxy (max y))
         (x-at-maxy (select x (first (last (order y)))))
         (max-pix-now (second (send self :real-to-canvas x-at-maxy maxy)))
         (zero-pix (second (send self :real-to-canvas x-at-maxy 0)))
         (y (* y (/ (- zero-pix 50) (- zero-pix max-pix-now))))
         (overlay (first (send self :slot-value 'overlays)))
         )
    (when (not line-width) (setf line-width *line-width*))
    (send self :add-lines (append (repeat (list x) ndim) (list y)) 
          :draw nil
         ; :color (if (and (send overlay :color-mode)
         ;                 (> *color-mode* 0) ) color nil)
          :color color ;(send self :kernel-curve-color)
          :width line-width)
    (when draw (send self :redraw))))



(defmeth histogram-proto :add-monopoly-dens 
                         ( &key (color 'green) (line-width 2))
  (let* ((current-variable (first (send self :content-variables)))
         (npts (send self :num-points))
         (ndim (- (send self :num-variables) 1))
         (varx (send self :point-coordinate current-variable (iseq npts)))
         (range (send self :range current-variable))
         (x (rseq (min varx) (max varx) 50))
         (maxyaxis (max (send self :range (1- (send self :num-variables)))))
         (y (second (monopoly-dens varx :xvals 50)))
         (maxy (max y))
         (x-at-maxy (select x (first (last (order y)))))
         (max-pix-now (second (send self :real-to-canvas x-at-maxy maxy)))
         (zero-pix (second (send self :real-to-canvas x-at-maxy 0)))
         (y (* y (/ (- zero-pix 50) (- zero-pix max-pix-now))))
         )
    (when (or (not (send self :use-color)) (= *color-mode* 0) )
                (setf color 'black))
    (send self :add-lines (append (repeat (list x) ndim) (list y)) 
          :color color :width line-width)
    ))

(defmeth histogram-proto :show-new-var (axis variable)
  (let* ((slider (send self :slot-value 'slider))
         (var-num (position variable (send self :variable-labels))))
    (send self :clear-lines :draw nil)
    (send self :content-variables var-num (- (send self :num-variables) 1))
    (send self :adjust-to-data)
    (when slider (send slider :value (- (send self :num-bins) 2)))
    (when (send self :show-normal) (send self :add-normal))
    (when (send self :show-kernel) 
          (send self :add-kernel (send self :kernel-type)))))

(defmeth histogram-proto :make-show-variables-list (&optional cur-vars)
  (let* ((variables (combine (send self :variable-labels)))
         (cur-vars (list (first (send self :current-variables)))))
    (set-difference variables (select variables cur-vars))))


(defmeth histogram-proto :new-bins ()
  (let* ((loc (send self :location))
         (size (send self :frame-size))
         (slider nil)
         )
    (cond 
      ((< (send self :num-points) 5)
       (vista-message "Not available when the number of data values being plotted in the histogram is less than 5."))
      ((not (send self :slot-value 'slider))
       (setf slider (sequence-slider-dialog 
                     (iseq 2 (send self :num-points))
                     :title "Number of Bins"
                     :action #'(lambda (x)
                                 (send self :clear-lines) 
                                 (send self :num-bins x)
                                 (when (send self :show-normal)
                                       (send self :show-normal nil)
                                       (send self :switch-add-normal :draw nil))
                                 (when (send self :show-kernel)
                                       (send self :show-kernel nil)
                                       (send self :switch-add-kernel :draw nil))
                                 (send self :redraw-content)
                                 )))
       (send slider :location 
             (floor (- (+ (/ (first size) 2) (first loc)) 
                       (/ (first (send slider :size)) 2))) (second loc))
       (send self :add-subordinate slider)
       (send self :slot-value 'slider slider)
       (send slider :value (- (send self :num-bins) 2))
       )
      (t (setf slider (send self :slot-value 'slider))
         (send slider :show-window)))))
